C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C YXLIB Customisation Parameters
C ------------------------------
 
C Routine Names
C -------------
 
C Field Definitions: Parse Tree Attributes
C ----------------------------------------
C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
C       NOT BE USED, as ordinary arithmetic is used to extract some fields
 
C Attribute Table Macros
C ----------------------
 
C YXLIB Bits
C ----------
 
C YXLIB Local Record Macros
C -------------------------
C   type VARX = record
C                   su: integer;    (* Storage units for variable *)
C                   common: ^(S_COMMON) or -maxint..-1;
C                                   (* ^(common block symbol), nil (0) or
C                                      negative of equivalence class number *)
C                   comsize: integer;(* Offset in common or equiv class *)
C                   equiv: ^EQV;    (* Pointer to equivalence link *)
C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
C                                   (* array information stored here *)
C               end;
C
C   type ARRAYX = record
C                   elts: integer;  (* Number of elements in the array *)
C                   dims: integer;  (* Number of dimensions of the array *)
C                   limits: array [1..dims] of
C                               record LOWER,UPPER: integer end
C                 end;
 
 
C   type EQH = HEAD record          (* Equivalence head record *)
C                       common: ^(S_COMMON) or -maxint..-1;
C                       usage: set of usage_bits
C                   end;
 
C   type EQV = LINK record          (* Equivalence variable record (link) *)
C                       sudif: integer;
C                       symbol: ^(S_VAR)
C                   end;
 
C   type LPR = record
C                   glob: ^(GPU) or -^(GEX);
C                   nargs: integer;
C                   args: array [1..nargs] of packed record
C                               dtype: min_dtype..max_dtype;
C                               argument_type: atype;
C                               descendents: ^HEAD;
C                               if dtype=type_char then
C                                   min_length, max_length: integer
C                               end if
C                           end record
C              end;
 
C                                   (* Argument type definitions *)
C   type ATYPE = (scalar,arelm,array,proc,label);
C   const min_atype = scalar; max_atype = label;
 
C YXLIB Record Definition: Semi-Local
C -----------------------------------
C   type PAREC = LINK record
C                   argnum: integer; (* Argument number passed down as *)
C                   prsym: ^(S_PROC); (* Procedure passed down to *)
C                   argsym: ^symbol; (* Actual argument being passed down *)
C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
C                   stmtno: integer; (* Statement number of assoc (context) *)
C                end;
 
C   type UNSAF = LINK record
C                   code: 1..5;     (* Type of unsafe reference to be checked *)
C                   argnum: integer;(* Argument number applicable *)
C                   extra: anything;(* Extra data (not used by inherit_expr) *)
C                   pusym: ^(S_PU); (* Context: associating program-unit *)
C                   stmtno: integer;(* Context: statement number *)
C                   prsym: ^(S_PROC)(* proc being called *)
C                end;
 
C YXLIB Global Record Macros
C --------------------------
C
C   type G_COM = record             Global common block record
C                   size: integer;
C                   type: (character,numeric,mixed); (* logical = numeric *)
C                   save: (saved,not_saved,only_in_main);
C                   init: integer   (* Number of times init'ed by block data *)
C                end;
 
C
C   type G_PU = record              Global program-unit record
C                   dtype: integer;
C                   chrlen: integer;
C                   culist: ^HEAD;  (* common block usage list header ptr *)
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   entrys: ^(HEAD) record ^G_ENT end;
C                   args: array [1..nargs] of gpuarg
C               end;
 
C   type G_ENT = record
C                   dtype: integer;
C                   chrlen: integer;
C                   pu: ^G_PU;
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   args: array [1..nargs] of ^guparg
C                end;
 
C type gpuarg = record
C                   dtype,chlen: integer;
C                   usage: (arg,read,update);
C                   struc: (scal,array,proc,label);
C                   size: integer;
C                   pass: ^HEAD;
C                   inh: ^HEAD(inherit)
C               end;
C type inherit = record
C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
C                   ass: ^(GPU);    (* associating program-unit *)
C                   snum: integer;  (* statement number of association *)
C                   if (type=proc) then
C                       gsyptr: ^(GPU)/-^(GEX)
C                   else
C                       extra: integer (* unsafe ref extra data *)
C                   end if
 
 
C Global Descendant Routine Types
C -------------------------------
 
C Error Codes returned by YXLIB
C -----------------------------
C ======================================================================
C
C       I S T S A   -   Main program for Toolpack/1 Semantic Analyser
C
C ======================================================================
 
        PROGRAM ISTSA
 
        INTEGER PATHL
        PARAMETER (PATHL=81+1)
 
        INTEGER TREPTH(PATHL),SYMPTH(PATHL),MTRPTH(PATHL),
     +          MSYPTH(PATHL),ATRPTH(PATHL)
 
        INTEGER IODTRE,IODSYM,IODATR,NERROR,NWARN
        LOGICAL REWTRE,REWSYM
 
        INTEGER GETARG,OPEN,CREATE
        EXTERNAL ZINIT,GETARG,ZQUIT,ZYINPT,ZYINSY,CLOSE,OPEN,CREATE,
     +           ZYXZIA,ZYXOAS,ZYSOUT,ZMESS
 
        CALL ZINIT
 
        CALL ZMESS('ISTSA - Toolpack Semantic Analyser, Version 1..1',
     +             1)
 
        IF (GETARG(1,TREPTH,81).EQ.-100) CALL NAMES(TREPTH,1)
        IF (GETARG(2,SYMPTH,81).EQ.-100) CALL NAMES(SYMPTH,2)
        IF (GETARG(3,MTRPTH,81).EQ.-100) CALL NAMES(MTRPTH,3)
        IF (GETARG(4,MSYPTH,81).EQ.-100) CALL NAMES(MSYPTH,4)
        IF (GETARG(5,ATRPTH,81).EQ.-100) CALL NAMES(ATRPTH,5)
 
        NERROR=0
        NWARN=0
 
        IODTRE=OPEN(TREPTH,0)
        IF (IODTRE.EQ.-1) CALL ERROR('Can''t open parse tree')
        IODSYM=OPEN(SYMPTH,0)
        IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol table')
        IODATR=CREATE(ATRPTH,1)
        IF (IODATR.EQ.-1) CALL ERROR('Can''t create attribute file')
 
        REWTRE=MTRPTH(1).EQ.129
        REWSYM=MSYPTH(1).EQ.129
        IF (MTRPTH(1).EQ.45) REWTRE=MTRPTH(2).EQ.129
        IF (MSYPTH(1).EQ.45) REWSYM=MSYPTH(2).EQ.129
 
        CALL ZYINPT(IODTRE)
        CALL CLOSE(IODTRE)
        CALL ZYINSY(IODSYM)
        CALL CLOSE(IODSYM)
        CALL ZYXZIA
 
        CALL ANALYS(.TRUE.,NERROR,NWARN)
 
        IF (NERROR.GT.0) THEN
            CALL ZMESS('[ISTSA Terminated, Errors detected]',2)
            CALL ZQUIT(-1)
        ELSE
            IF (REWTRE) THEN
                IODTRE=CREATE(TREPTH,1)
            ELSE
                IODTRE=CREATE(MTRPTH,1)
            END IF
            IF (IODTRE.EQ.-1) CALL ERROR('Can''t create modified tree')
            CALL ZYTOUT(IODTRE)
            IF (REWSYM) THEN
                IODSYM=CREATE(SYMPTH,1)
            ELSE
                IODSYM=CREATE(MSYPTH,1)
            END IF
            IF (IODSYM.EQ.-1)
     +          CALL ERROR('Can''t create modified symbol table')
            CALL ZYSOUT(IODSYM)
            CALL ZYXOAS(IODATR)
            IF (NWARN.GT.0) THEN
                CALL ZMESS('[ISTSA Terminated, Warnings produced]',2)
                CALL ZQUIT(-1002)
            ELSE
                CALL ZMESS('[ISTSA Normal Termination]',2)
                CALL ZQUIT(-2)
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       N A M E S   -   Prompt user for filenames
C
 
        SUBROUTINE NAMES(PATH,NUMBER)
        INTEGER PATH(*),NUMBER
 
        INTEGER PROMPT(24,5),I
 
        SAVE PROMPT
 
        INTEGER ZGTCMD
        EXTERNAL ZGTCMD,ZPRMPT,ERROR
 
C "Input parse tree: "
C "Input symbol table: "
C "Modified parse tree: "
C "Modified symbol table: "
C "Attribute file: "
 
        DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,112,
     +97,114,115,101,32,116,114,101,101,58,32,129/,
     +       (PROMPT(I,2),I=1,21)/73,110,112,117,116,32,115,
     +121,109,98,111,108,32,116,97,98,108,101,58,
     +32,129/,
     +       (PROMPT(I,3),I=1,22)/77,111,100,105,102,105,101,
     +100,32,112,97,114,115,101,32,116,114,101,101,
     +58,32,129/,
     +       (PROMPT(I,4),I=1,24)/77,111,100,105,102,105,101,
     +100,32,115,121,109,98,111,108,32,116,97,98,
     +108,101,58,32,129/,
     +       (PROMPT(I,5),I=1,17)/65,116,116,114,105,98,117,
     +116,101,32,102,105,108,101,58,32,129/
 
        CALL ZPRMPT(PROMPT(1,NUMBER))
        IF (ZGTCMD(PATH,0).EQ.-1)
     +      CALL ERROR('ZGTCMD returned Error status')
 
        END
 
